home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / fortran / f2c_src.zip / F2C / LIBI77 / LREAD.C < prev    next >
C/C++ Source or Header  |  1991-06-10  |  10KB  |  527 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. #include "ctype.h"
  6. #include "fp.h"
  7.  
  8. extern char *fmtbuf;
  9. extern char *malloc(), *realloc();
  10. int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
  11. int l_eof;
  12.  
  13. #define isblnk(x) (ltab[x+1]&B)
  14. #define issep(x) (ltab[x+1]&SX)
  15. #define isapos(x) (ltab[x+1]&AX)
  16. #define isexp(x) (ltab[x+1]&EX)
  17. #define issign(x) (ltab[x+1]&SG)
  18. #define iswhit(x) (ltab[x+1]&WH)
  19. #define SX 1
  20. #define B 2
  21. #define AX 4
  22. #define EX 8
  23. #define SG 16
  24. #define WH 32
  25. char ltab[128+1] = {    /* offset one for EOF */
  26.     0,
  27.     0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  28.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  29.     SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  30.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  31.     0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  32.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  33.     AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  34.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  35. };
  36.  
  37. t_getc()
  38. {    int ch;
  39.     if(curunit->uend) return(EOF);
  40.     if((ch=getc(cf))!=EOF) return(ch);
  41.     if(feof(cf))
  42.         l_eof = curunit->uend = 1;
  43.     return(EOF);
  44. }
  45. integer e_rsle()
  46. {
  47.     int ch;
  48.     if(curunit->uend) return(0);
  49.     while((ch=t_getc())!='\n' && ch!=EOF);
  50.     return(0);
  51. }
  52.  
  53. flag lquit;
  54. int lcount,ltype;
  55. char *lchar;
  56. double lx,ly;
  57. #define ERR(x) if(n=(x)) return(n)
  58. #define GETC(x) (x=(*l_getc)())
  59. #define Ungetc(x,y) (*l_ungetc)(x,y)
  60.  
  61. l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  62. {
  63. #define Ptr ((flex *)ptr)
  64.     int i,n,ch;
  65.     doublereal *yy;
  66.     real *xx;
  67.     for(i=0;i<*number;i++)
  68.     {
  69.         if(lquit) return(0);
  70.         if(l_eof)
  71.             err(elist->ciend, EOF, "list in")
  72.         if(lcount == 0) {
  73.             ltype = 0;
  74.             for(;;)  {
  75.                 GETC(ch);
  76.                 switch(ch) {
  77.                 case EOF:
  78.                     goto loopend;
  79.                 case ' ':
  80.                 case '\t':
  81.                 case '\n':
  82.                     continue;
  83.                 case '/':
  84.                     lquit = 1;
  85.                     goto loopend;
  86.                 case ',':
  87.                     lcount = 1;
  88.                     goto loopend;
  89.                 default:
  90.                     (void) Ungetc(ch, cf);
  91.                     goto rddata;
  92.                 }
  93.             }
  94.         }
  95.     rddata:
  96.         switch((int)type)
  97.         {
  98.         case TYSHORT:
  99.         case TYLONG:
  100.         case TYREAL:
  101.         case TYDREAL:
  102.             ERR(l_R(0));
  103.             break;
  104.         case TYCOMPLEX:
  105.         case TYDCOMPLEX:
  106.             ERR(l_C());
  107.             break;
  108.         case TYLOGICAL:
  109.             ERR(l_L());
  110.             break;
  111.         case TYCHAR:
  112.             ERR(l_CHAR());
  113.             break;
  114.         }
  115.     while (GETC(ch) == ' ' || ch == '\t');
  116.     if (ch != ',')
  117.         Ungetc(ch,cf);
  118.     loopend:
  119.         if(lquit) return(0);
  120.         if(cf) {
  121.             if (feof(cf))
  122.                 err(elist->ciend,(EOF),"list in")
  123.             else if(ferror(cf)) {
  124.                 clearerr(cf);
  125.                 err(elist->cierr,errno,"list in")
  126.                 }
  127.             }
  128.         if(ltype==0) goto bump;
  129.         switch((int)type)
  130.         {
  131.         case TYSHORT:
  132.             Ptr->flshort=lx;
  133.             break;
  134.         case TYLOGICAL:
  135.         case TYLONG:
  136.             Ptr->flint=lx;
  137.             break;
  138.         case TYREAL:
  139.             Ptr->flreal=lx;
  140.             break;
  141.         case TYDREAL:
  142.             Ptr->fldouble=lx;
  143.             break;
  144.         case TYCOMPLEX:
  145.             xx=(real *)ptr;
  146.             *xx++ = lx;
  147.             *xx = ly;
  148.             break;
  149.         case TYDCOMPLEX:
  150.             yy=(doublereal *)ptr;
  151.             *yy++ = lx;
  152.             *yy = ly;
  153.             break;
  154.         case TYCHAR:
  155.             b_char(lchar,ptr,len);
  156.             break;
  157.         }
  158.     bump:
  159.         if(lcount>0) lcount--;
  160.         ptr += len;
  161.     }
  162.     return(0);
  163. #undef Ptr
  164. }
  165. l_R(poststar)
  166.  int poststar;
  167. {
  168.     char s[FMAX+EXPMAXDIGS+4];
  169.     register int ch;
  170.     register char *sp, *spe, *sp1;
  171.     long e, exp;
  172.     double atof();
  173.     int havenum, se;
  174.  
  175.     if (!poststar) {
  176.         if (lcount > 0)
  177.             return(0);
  178.         lcount = 1;
  179.         }
  180.     ltype = 0;
  181.     exp = 0;
  182. retry:
  183.     sp1 = sp = s;
  184.     spe = sp + FMAX;
  185.     havenum = 0;
  186.  
  187.     switch(GETC(ch)) {
  188.         case '-': *sp++ = ch; sp1++; spe++;
  189.         case '+':
  190.             GETC(ch);
  191.         }
  192.     while(ch == '0') {
  193.         ++havenum;
  194.         GETC(ch);
  195.         }
  196.     while(isdigit(ch)) {
  197.         if (sp < spe) *sp++ = ch;
  198.         else ++exp;
  199.         GETC(ch);
  200.         }
  201.     if (ch == '*' && !poststar) {
  202.         if (sp == sp1 || exp || *s == '-') {
  203.             err(elist->cierr,112,"bad repetition count")
  204.             }
  205.         poststar = 1;
  206.         *sp = 0;
  207.         lcount = atoi(s);
  208.         goto retry;
  209.         }
  210.     if (ch == '.') {
  211.         GETC(ch);
  212.         if (sp == sp1)
  213.             while(ch == '0') {
  214.                 ++havenum;
  215.                 --exp;
  216.                 GETC(ch);
  217.                 }
  218.         while(isdigit(ch)) {
  219.             if (sp < spe)
  220.                 { *sp++ = ch; --exp; }
  221.             GETC(ch);
  222.             }
  223.         }
  224.     se = 0;
  225.     if (issign(ch))
  226.         goto signonly;
  227.     if (isexp(ch)) {
  228.         GETC(ch);
  229.         if (issign(ch)) {
  230. signonly:
  231.             if (ch == '-') se = 1;
  232.             GETC(ch);
  233.             }
  234.         if (!isdigit(ch)) {
  235. bad:
  236.             err(elist->cierr,112,"exponent field")
  237.             }
  238.  
  239.         e = ch - '0';
  240.         while(isdigit(GETC(ch))) {
  241.             e = 10*e + ch - '0';
  242.             if (e > EXPMAX)
  243.                 goto bad;
  244.             }
  245.         if (se)
  246.             exp -= e;
  247.         else
  248.             exp += e;
  249.         }
  250.     (void) Ungetc(ch, cf);
  251.     if (sp > sp1) {
  252.         ++havenum;
  253.         while(*--sp == '0')
  254.             ++exp;
  255.         if (exp)
  256.             sprintf(sp+1, "e%ld", exp);
  257.         else
  258.             sp[1] = 0;
  259.         lx = atof(s);
  260.         }
  261.     else
  262.         lx = 0.;
  263.     if (havenum)
  264.         ltype = TYLONG;
  265.     else
  266.         switch(ch) {
  267.             case ',':
  268.             case '/':
  269.                 break;
  270.             default:
  271.                 err(elist->cierr,112,"invalid number")
  272.             }
  273.     return 0;
  274.     }
  275.  
  276.  static int
  277. rd_count(ch)
  278.  register int ch;
  279. {
  280.     if (ch < '0' || ch > '9')
  281.         return 1;
  282.     lcount = ch - '0';
  283.     while(GETC(ch) >= '0' && ch <= '9')
  284.         lcount = 10*lcount + ch - '0';
  285.     Ungetc(ch,cf);
  286.     return 0;
  287.     }
  288.  
  289. l_C()
  290. {    int ch;
  291.     double lz;
  292.     if(lcount>0) return(0);
  293.     ltype=0;
  294.     GETC(ch);
  295.     if(ch!='(')
  296.     {
  297.         if (rd_count(ch))
  298.             if(!cf || !feof(cf))
  299.                 err(elist->cierr,112,"complex format")
  300.             else
  301.                 err(elist->cierr,(EOF),"lread");
  302.         if(GETC(ch)!='*')
  303.         {
  304.             if(!cf || !feof(cf))
  305.                 err(elist->cierr,112,"no star")
  306.             else
  307.                 err(elist->cierr,(EOF),"lread");
  308.         }
  309.         if(GETC(ch)!='(')
  310.         {    (void) Ungetc(ch,cf);
  311.             return(0);
  312.         }
  313.     }
  314.     else
  315.         lcount = 1;
  316.     while(iswhit(GETC(ch)));
  317.     (void) Ungetc(ch,cf);
  318.     if (ch = l_R(1))
  319.         return ch;
  320.     if (!ltype)
  321.         err(elist->cierr,112,"no real part");
  322.     lz = lx;
  323.     while(iswhit(GETC(ch)));
  324.     if(ch!=',')
  325.     {    (void) Ungetc(ch,cf);
  326.         err(elist->cierr,112,"no comma");
  327.     }
  328.     while(iswhit(GETC(ch)));
  329.     (void) Ungetc(ch,cf);
  330.     if (ch = l_R(1))
  331.         return ch;
  332.     if (!ltype)
  333.         err(elist->cierr,112,"no imaginary part");
  334.     while(iswhit(GETC(ch)));
  335.     if(ch!=')') err(elist->cierr,112,"no )");
  336.     ly = lx;
  337.     lx = lz;
  338.     return(0);
  339. }
  340. l_L()
  341. {
  342.     int ch;
  343.     if(lcount>0) return(0);
  344.     ltype=0;
  345.     GETC(ch);
  346.     if(isdigit(ch))
  347.     {
  348.         rd_count(ch);
  349.         if(GETC(ch)!='*')
  350.             if(!cf || !feof(cf))
  351.                 err(elist->cierr,112,"no star")
  352.             else
  353.                 err(elist->cierr,(EOF),"lread");
  354.         GETC(ch);
  355.     }
  356.     if(ch == '.') GETC(ch);
  357.     switch(ch)
  358.     {
  359.     case 't':
  360.     case 'T':
  361.         lx=1;
  362.         break;
  363.     case 'f':
  364.     case 'F':
  365.         lx=0;
  366.         break;
  367.     default:
  368.         if(isblnk(ch) || issep(ch) || ch==EOF)
  369.         {    (void) Ungetc(ch,cf);
  370.             return(0);
  371.         }
  372.         else    err(elist->cierr,112,"logical");
  373.     }
  374.     ltype=TYLONG;
  375.     lcount = 1;
  376.     while(!issep(GETC(ch)) && ch!=EOF);
  377.     (void) Ungetc(ch, cf);
  378.     return(0);
  379. }
  380. #define BUFSIZE    128
  381. l_CHAR()
  382. {    int ch,size,i;
  383.     char quote,*p;
  384.     if(lcount>0) return(0);
  385.     ltype=0;
  386.     if(lchar!=NULL) free(lchar);
  387.     size=BUFSIZE;
  388.     p=lchar=malloc((unsigned int)size);
  389.     if(lchar==NULL) err(elist->cierr,113,"no space");
  390.  
  391.     GETC(ch);
  392.     if(isdigit(ch)) {
  393.         /* allow Fortran 8x-style unquoted string...    */
  394.         /* either find a repetition count or the string    */
  395.         lcount = ch - '0';
  396.         *p++ = ch;
  397.         for(i = 1;;) {
  398.             switch(GETC(ch)) {
  399.                 case '*':
  400.                     if (lcount == 0) {
  401.                         lcount = 1;
  402.                         goto noquote;
  403.                         }
  404.                     p = lchar;
  405.                     goto have_lcount;
  406.                 case ',':
  407.                 case ' ':
  408.                 case '\t':
  409.                 case '\n':
  410.                 case '/':
  411.                     Ungetc(ch,cf);
  412.                     /* no break */
  413.                 case EOF:
  414.                     lcount = 1;
  415.                     ltype = TYCHAR;
  416.                     return *p = 0;
  417.                 }
  418.             if (!isdigit(ch)) {
  419.                 lcount = 1;
  420.                 goto noquote;
  421.                 }
  422.             *p++ = ch;
  423.             lcount = 10*lcount + ch - '0';
  424.             if (++i == size) {
  425.                 lchar = realloc(lchar,
  426.                     (unsigned int)(size += BUFSIZE));
  427.                 p = lchar + i;
  428.                 }
  429.             }
  430.         }
  431.     else    (void) Ungetc(ch,cf);
  432.  have_lcount:
  433.     if(GETC(ch)=='\'' || ch=='"') quote=ch;
  434.     else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
  435.     {    (void) Ungetc(ch,cf);
  436.         return(0);
  437.     }
  438.     else {
  439.         /* Fortran 8x-style unquoted string */
  440.         *p++ = ch;
  441.         for(i = 1;;) {
  442.             switch(GETC(ch)) {
  443.                 case ',':
  444.                 case ' ':
  445.                 case '\t':
  446.                 case '\n':
  447.                 case '/':
  448.                     Ungetc(ch,cf);
  449.                     /* no break */
  450.                 case EOF:
  451.                     ltype = TYCHAR;
  452.                     return *p = 0;
  453.                 }
  454.  noquote: